// RealPlay Ltd  copyrights.
// This program is Open Source AsIs
// You may use it for all purposes, including commercial
// But!!!
// If you use any part of this code, you must state clearly
// both in your source file and in the Help|about of your program,
// that the origin program or code was built by RealPlay Ltd

// ***********************************************************************/
// *                                                                     */
// *        This unit ctrl contains utils for  "Paint" Program           */
// *                                                                     */
// ***********************************************************************/

unit UPUtil;

interface

uses Windows, Dialogs, Classes, Graphics, SysUtils, ExtCtrls, Registry;
// UPFrWorkArea;

Type
  TStat = class(Tobject)
  private
    fch: boolean;
    fx, fy: integer;
    fcx, fcy: real;
    fMyWA: Tobject; // TFrameWorkArea;
    procedure setchanged(v: boolean);
    procedure setX(v: integer);
    procedure setY(v: integer);
    procedure setcX(v: real);
    procedure setcY(v: real);
  public
    // property
    constructor create(AFWA: Tobject); overload;
    procedure SetSize;
    property Changed: boolean read fch write setchanged default false;
    property X: integer read fx write setX;
    property Y: integer read fy write setY;
    property CX: real read fcx write setcX;
    property CY: real read fcy write setcY;
  end;

  // ******************************************************************************
  // Procedures for file and register operations
  // ******************************************************************************

function ExtFileExt: string;
function ExtFileName: string;
function CheckIfAni: boolean;
function SaveOrExit: boolean;

Const
  PingTrig: string =
    '\Software\Microsoft\Windows\CurrentVersion\Applets\Paint\PingTrig';
  RecentFiles: string =
    '\Software\Microsoft\Windows\CurrentVersion\Applets\Paint\Recent File List';
  BrowserPathKey = '\HTTP\shell\open\command';

procedure PingTrigWrite(st: string);
function PingTrigRead: string;

Function BrowserPath: AnsiString;

procedure writefilename(st: string);
function readfilenames: Tstringlist;

// ******************************************************************************
// Graph Procedures and types operations
// ******************************************************************************

const
  PixelCountMax = $FFFF;

type
  colorRec = packed record
    case col: integer of
      0:
        (RGB: TRGBTriple; );
      1:
        (int: longint);
      2:
        (color: TColor);
  end;

  TRGBTripleArray = ARRAY [0 .. PixelCountMax - 1] OF TRGBTriple;
  PRGBline = ^TRGBTripleArray;

procedure AssBMP(S: TBitmap; D: TImage); // Assign D to S with bug fix of Delphi 6 transperent
procedure drawtrans(src, dst: TBitmap; X, Y: integer; color: TColor = -1);
// draws src on the dst with transperancy
function Stretch(bS, bD: TBitmap; ANw, ANh: real): boolean;
Procedure TurnBitMap(src: TBitmap; CCW: boolean);
procedure RotateBitmap(var hBitmapDC: longint; var lWidth: longint;
  var lHeight: longint; lRadians: real);

Procedure Invert(bmp: TBitmap);
function WhiteToBlack(img: TImage): TBitmap;
function BlackToWhite(img: TImage): TBitmap;
function ReplaceColor(srcBitmap: TBitmap; fromColor: TColor;
  toColor: TColor): TBitmap;

type
  Ppoint = ^TPoint;
  TPointArray = array of TPoint;

  TpointList = class(Tstringlist)
  private
    function GetPoint(Index: integer): TPoint;
    procedure SetPoint(Index: integer; Value: TPoint);
    function PointToStr(APoint: TPoint): string;
    function StrToPoint(AString: string): TPoint;
  public
    procedure line(x1, y1, x2, y2: integer);
    procedure InsertPoint(Index: integer; APoint: TPoint);
    function AddPoint(const APoint: TPoint): integer;
    function AsPointArray: TPointArray;
    property points[Index: integer]: TPoint read GetPoint write SetPoint;
    default;
  end;

  // ______________________________________________________________________
implementation

uses UPMain, UPMenu, math, UPFrWorkArea, UPActions;

var
  TmpBrush: TBrush;
  TmpPen: TPen;
  TmpFont: TFont;

  // *****************************************************************
  // TpointList =class (tstringlist)
  // *****************************************************************
procedure TpointList.line(x1, y1, x2, y2: integer);
Var
  i, xlen, ylen, up: integer;
  step: real;
begin
  clear;
  xlen := x1 - x2;
  ylen := y1 - y2;
  if max(abs(xlen), abs(ylen)) > 1 then
  begin
    if abs(xlen) > abs(ylen) then // run on x axis
    begin
      step := ylen / xlen;
      if x1 > x2 then
        up := -1
      else
        up := 1;
      for i := 0 to abs(xlen) - 1 do
        AddPoint(point(x1 + (i * up), y1 + round(step * i * up)));
    end
    else
    begin
      step := xlen / ylen;
      if y1 > y2 then
        up := -1
      else
        up := 1;
      for i := 0 to abs(ylen) - 1 do
        AddPoint(point(x1 + round(step * i * up), y1 + (i * up)));
    end;
  end;
end;

// *****************************************************************
function TpointList.AsPointArray: TPointArray;
var
  i: integer;
begin
  setlength(result, count);
  for i := 0 to count - 1 do
    result[i] := points[i];
end;

// *****************************************************************
procedure TpointList.SetPoint(Index: integer; Value: TPoint);
begin
  if Index < count then
  begin
    delete(index);
    insert(index, PointToStr(Value));
  end;
end;

// *****************************************************************
function TpointList.GetPoint(Index: integer): TPoint;
begin
  result := StrToPoint(strings[Index]);
end;
// *****************************************************************

Procedure TpointList.InsertPoint(Index: integer; APoint: TPoint);
begin
  insert(index, PointToStr(APoint));
end;

// *****************************************************************
function TpointList.AddPoint(const APoint: TPoint): integer;
begin
  result := add(PointToStr(APoint));
end;

// *****************************************************************
function TpointList.PointToStr(APoint: TPoint): string;
begin
  result := string(@APoint);
  setlength(result, sizeof(TPoint));
end;

// ***************************************************************
function TpointList.StrToPoint(AString: string): TPoint;
begin
  result := TPoint(pointer(AString)^);
end;

// End of TpointList ******************************************************
procedure AssBMP(S: TBitmap; D: TImage); // Assign S to D Image with bug fix of Delphi 6 transperent
begin
  with D.Picture.Bitmap.Canvas do
  begin
    TmpBrush.Assign(Brush);
    TmpPen.Assign(Pen);
    TmpFont.Assign(font);
    D.Picture.Assign(S); // replace the image picture(bitmap);
  end;
  with D.Picture.Bitmap.Canvas do // because the Image was replaced this is a new bitmap with new canvas
  begin
    Pixels[0, 0] := Pixels[0, 0]; // bugfix in assign (not like the above Bug
    // the bug needs this pix write to recover when transparent=true;

    Brush.Assign(TmpBrush);
    Pen.Assign(TmpPen);
    font.Assign(TmpFont);
  end;
end;

// *****************************************************************************
function ColorToRGB(cl: TColor): TRGBTriple;
begin
  result.rgbtBlue := (cl and $FF0000) shr 16;
  result.rgbtgreen := (cl and $FF00) shr 8;
  result.rgbtred := (cl and $FF);
end;

procedure drawtrans(src, dst: TBitmap; X, Y: integer; color: TColor = -1);
// draws src on the dst with transperancy
var
  w, h: integer;
  cl, Ncl, trans: colorRec;
  ps, pd: PRGBline;
begin
  src.PixelFormat := pf24bit;
  dst.PixelFormat := pf24bit;
  cl.int := 0; // zero all cl bits;
  Ncl.int := 0;
  Ncl.RGB := ColorToRGB(color); // and $ffffff;
  trans.int := 0;
  trans.RGB := ColorToRGB(src.TransparentColor); // and $ffffff;
  for h := 0 to src.Height - 1 do
    if ((Y + h) < dst.Height) and ((Y + h) >= 0) then
    begin
      ps := src.ScanLine[h];
      pd := dst.ScanLine[h + Y];
      for w := 0 to src.Width - 1 do
        if ((w + X) < dst.Width) and ((w + X) >= 0) then
        begin
          cl.RGB := ps[w];
          if cl.int <> trans.int then
            if color = -1 then
              pd[w + X] := cl.RGB
            else
              pd[w + X] := Ncl.RGB;
        end;
    end;
  dst.Modified := true; // Some 2 hour to find that refresh works only if moditied is true!
  dst.Canvas.Refresh;
end;

// *********************************************************************************
function ExtFileExt: string;
begin
  result := uppercase(ExtractFileExt(FMenu.opd1.FileName));
end;

function ExtFileName: string;
begin
  result := ExtractFileName(changeFileExt(FMenu.opd1.FileName, ''));
end;

function CheckIfAni: boolean;
begin
  result := fileExists(changeFileExt(FMenu.opd1.FileName, '.xml'));
  FPaint.IsAni := result;
  FPaint.FrRTool1.mp.Visible := result;
  FPaint.FrRTool1.mp.Enabled := result;
  if result then
    FMenu.ARealPlayExecute(nil); ;
end;

function SaveOrExit: boolean;
begin
  result := false;
{$IF not Defined(DEBUG)}
  if FPaint.FWA.Mystat.Changed then
    case MessageDlg('Save changes to ' + FMenu.opd1.FileName + '?',
      mtConfirmation, [mbYes, mbNo, mbCancel], 0) of
      idYes:
        ActionFileSave;
      idCANCEL:
        result := true;
    end;
{$IFEND}
end;
// *****************************************************************************
// TStat
// *****************************************************************************

constructor TStat.create(AFWA: Tobject);
begin
  inherited create;
  fMyWA := AFWA;
end;

procedure TStat.SetSize;
begin
  setcX(UPMain.ZoomXr);
  setcY(UPMain.ZoomYr);
  with TFrameWorkArea(fMyWA) do
  begin
    clear;
    ImPanel.Height := ImBottomPanel.Height + round
      (Im.Picture.Height * UPMain.ZoomYr);
    ImPanel.Width := ImRightPanel.Width + round
      (Im.Picture.Width * UPMain.ZoomXr);
  end;
end;

// **********************************************
procedure TStat.setchanged(v: boolean);
begin
  FPaint.FWA.ZF.setF;
  if fch <> v then
  begin
    fch := v;
    with FPaint.SBar.Panels[0] do
      if fch then
        text := ' Changed '
      else
        text := '         ';
  end;
end;

// *******************************
procedure TStat.setX(v: integer);
begin
  if fx <> v then
  begin
    fx := v;
    with FPaint.SBar.Panels[1] do
      text := 'X=' + inttostr(fx);
  end;
end;

// *******************************
procedure TStat.setY(v: integer);
begin
  if fy <> v then
  begin
    fy := v;
    with FPaint.SBar.Panels[2] do
      text := 'Y=' + inttostr(fy);
  end;
end;
// ********************************

procedure TStat.setcY(v: real);
begin
  if (fcy <> v) and (v <> 0) then
  begin
    fcy := v;
    with FPaint.SBar.Panels[4] do
      text := 'Zoom Y=' + floattostrF(fcy, ffGeneral, 3, 4);
  end;
end;

procedure TStat.setcX(v: real);
begin
  if (fcx <> v) and (v <> 0) then
  begin
    fcx := v;
    with FPaint.SBar.Panels[3] do
      text := 'Zoom X=' + floattostrF(fcx, ffGeneral, 3, 4);
  end;
end;

// ********************  End STAT   **************************************
function BrowserPath: AnsiString;
var
  Reg: TRegistry;
  i: integer;
begin
  result := '';
  Reg := TRegistry.create;
  try
    Reg.RootKey := HKEY_CLASSES_ROOT;
    if Reg.OpenKey(BrowserPathKey, false) then
    begin
      result := Reg.ReadString('');
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
  i := pos('-', result);
  if i <> 0 then
    delete(result, i, 1000);
end;

function PingTrigRead: string;
var
  Reg: TRegistry;
begin
  result := '';
  Reg := TRegistry.create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey(PingTrig, false) then
    begin
      result := Reg.ReadString('Host');
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
end;

procedure PingTrigWrite(st: string);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey(PingTrig, true) then
    begin
      Reg.WriteString('Host', st);
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
end;

// *******************************************************
procedure Invert(bmp: TBitmap);
var
  w, h: integer;
  row: PRGBline;
begin
  bmp.PixelFormat := pf24bit;
  for h := 0 to bmp.Height - 1 do
  begin
    row := bmp.ScanLine[h];
    for w := 0 to bmp.Width - 1 do
      with row[w] do
      begin
        rgbtBlue := $FF - rgbtBlue;
        rgbtgreen := $FF - rgbtgreen;
        rgbtred := $FF - rgbtred;
      end;
  end;
  bmp.Modified := true;
  bmp.Canvas.Refresh;
end;

// ********************************************************
function BlackToWhite(img: TImage): TBitmap;
var
  i: integer;
  j: integer;
  row: PRGBline;
begin
  if img.Picture.Bitmap.PixelFormat = pf24bit then
    for j := 0 TO img.Picture.Bitmap.Height - 1 DO
    begin
      row := img.Picture.Bitmap.ScanLine[j];
      for i := 0 TO img.Picture.Bitmap.Width - 1 DO
        with row[i] do
          if (rgbtred = 0) and (rgbtgreen = 0) and (rgbtBlue = 0) then
          begin
            rgbtred := 255;
            rgbtgreen := 255;
            rgbtBlue := 255;
          end;
    end;
  result := img.Picture.Bitmap;
end;

function WhiteToBlack(img: TImage): TBitmap;
var
  i: integer;
  j: integer;
  row: PRGBline;
begin
  if img.Picture.Bitmap.PixelFormat = pf24bit then
    for j := 0 TO img.Picture.Bitmap.Height - 1 DO
    begin
      row := img.Picture.Bitmap.ScanLine[j];
      for i := 0 TO img.Picture.Bitmap.Width - 1 DO
        with row[i] do
          if (rgbtred = 255) and (rgbtgreen = 255) and (rgbtBlue = 255) then
          begin
            rgbtred := 0;
            rgbtgreen := 0;
            rgbtBlue := 0;
          end;
    end;
  result := img.Picture.Bitmap;
end;

function ReplaceColor(srcBitmap: TBitmap; fromColor: TColor;
  toColor: TColor): TBitmap;
var
  i: integer;
  j: integer;
  row: PRGBline;
  fromR, fromG, fromB: BYTE;
  toR, toG, toB: BYTE;
begin
  if srcBitmap.PixelFormat = pf24bit then
  begin
    fromR := fromColor and $000000FF;
    fromG := (fromColor shr 8) and $000000FF;
    fromB := (fromColor shr 16) and $000000FF;
    toR := toColor and $000000FF;
    toG := (toColor shr 8) and $000000FF;
    toB := (toColor shr 16) and $000000FF;
    for j := 0 TO srcBitmap.Height - 1 DO
    begin
      row := srcBitmap.ScanLine[j];
      for i := 0 TO srcBitmap.Width - 1 DO
        with row[i] do
          if (rgbtred = fromR) and (rgbtgreen = fromG) and (rgbtBlue = fromB)
            then
          begin
            rgbtred := toR;
            rgbtgreen := toG;
            rgbtBlue := toB;
          end;
    end;
  end;
  result := srcBitmap;
end;

function readfilenames: Tstringlist;
var
  Reg: TRegistry;
  i: integer;
  stt: string;
begin
  result := Tstringlist.create;
  Reg := TRegistry.create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey(RecentFiles, false) then
    begin
      i := 1;
      stt := Reg.ReadString('File1');
      while ('' <> stt) do
      begin
        result.add(stt);
        inc(i);
        stt := Reg.ReadString('File' + inttostr(i));
      end;
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
end;

// ***************************************
procedure writefilename(st: string);
var
  Reg: TRegistry;
  i, X: integer;
  stt: string;
begin
  Reg := TRegistry.create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey(RecentFiles, false) then
    begin
      i := 1;
      while ('' <> Reg.ReadString('File' + inttostr(i))) and
        (st <> Reg.ReadString('File' + inttostr(i))) do
        inc(i);
      if i >= 9 then
        i := 9;
      for X := i downto 2 do
      begin
        stt := Reg.ReadString('File' + inttostr(X - 1));
        Reg.WriteString('File' + inttostr(X), stt);
      end;
      Reg.WriteString('File1', st);
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
end;

// ****************************************************************************
// this function will stretch the bitmap
// into Nw(New Wiidth) Nh(New Height) pixel size.
// based on Frank Ditsche work
function Stretch(bS, bD: TBitmap; ANw, ANh: real): boolean;
var
  ARect: TRect;
  Nw, Nh: integer;
begin
  result := false;
  if (ANw < 5) or (ANh < 5) then
    exit;
  Nw := round(ANw);
  Nh := round(ANh);
  try
    bD.Width := Nw;
    bD.Height := Nh;
    ARect := Rect(0, 0, Nw, Nh);
    bD.Canvas.StretchDraw(ARect, bS);
    result := true;
  except
    result := false;
  end;
end;

// ***********************************************************************************

Procedure TurnBitMap(src: TBitmap; CCW: boolean);
var
  X, Y: integer;
  BitM: TBitmap;
begin
  BitM := TBitmap.create;
  BitM.Width := src.Height;
  BitM.Height := src.Width;
  if CCW then // clockwise rotate
    for X := 0 to src.Height - 1 do
      for Y := 0 to src.Width - 1 do
        BitM.Canvas.Pixels[X, Y] := src.Canvas.Pixels[Y, src.Height - X]
      else // counter-clockwise rotate
        for X := 0 to src.Height - 1 do
          for Y := 0 to src.Width - 1 do
            BitM.Canvas.Pixels[X, Y] := src.Canvas.Pixels[src.Width - Y, X];
  src.Assign(BitM);
  BitM.Free;
end;

// ************************************************************************************
var // global var for one time init
  RWin: TRect; // Rect for fill transperent on rotate
  Brush: TBrush;

procedure RotateBitmap(var hBitmapDC: longint; var lWidth: longint;
  var lHeight: longint; lRadians: real);
var
  i: longint; // loop counter
  j: longint; // loop counter
  hNewBitmapDC: longint; // DC of the new bitmap
  hNewBitmap: longint; // handle to the new bitmap
  lSine: extended; // sine used in rotation
  lCosine: extended; // cosine used in rotation
  x1, x2, X3, X4: longint; // used in calculating new bitmap dimensions
  y1, y2, Y3, Y4: longint; // used in calculating new bitmap dimensions
  lMinX, lMaxX, lMinY, lMaxY: longint; // used in calculating new bitmap dimensions
  lNewWidth: longint; // width of new bitmap
  lNewHeight: longint; // height of new bitmap
  lSourceX: longint; // x pixel coord we are blitting from the source  image
  lSourceY: longint; // y pixel coord we are blitting from the source image
begin
  // create a compatible DC from the one just brought into this function
  hNewBitmapDC := CreateCompatibleDC(hBitmapDC);

  // compute the sine/cosinse of the radians used to rotate this image
  lSine := Sin(lRadians);
  lCosine := Cos(lRadians);

  // compute the size of the new bitmap being created
  x1 := round(-lHeight * lSine);
  y1 := round(lHeight * lCosine);
  x2 := round(lWidth * lCosine - lHeight * lSine);
  y2 := round(lHeight * lCosine + lWidth * lSine);
  X3 := round(lWidth * lCosine);
  Y3 := round(lWidth * lSine);
  X4 := round(lHeight * lSine - lHeight * lSine);
  Y4 := round(lWidth * lCosine - lWidth * lCosine);

  // figure out the max/min size of the new bitmap
  lMinX := Min(Min(0, Min(x1, Min(x2, X3))), X4);
  lMinY := Min(Min(0, Min(y1, Min(y2, Y3))), Y4);
  lMaxX := max(max(x1, max(x2, X3)), X4);
  lMaxY := max(max(y1, max(y2, Y3)), Y4);

  // set the new bitmap width/height
  lNewWidth := lMaxX - lMinX;
  lNewHeight := lMaxY - lMinY;

  // create a new bitmap based upon the new width/height of the
  // rotated bitmap
  hNewBitmap := CreateCompatibleBitmap(hBitmapDC, lNewWidth, lNewHeight);

  // above before constructing the rotated bitmap
  SelectObject(hNewBitmapDC, hNewBitmap); // attach the new bitmap to the new device context created

  RWin := Rect(0, 0, lNewWidth, lNewHeight); // ido for transperent background
  Brush.color := FPaint.FWA.ImSelS.Picture.Bitmap.TransparentColor;
  fillrect(hNewBitmapDC, RWin, Brush.Handle); // fill $FFEFFF

  // loop through and translate each pixel to its new location.
  // this is using a standard rotation algorithm
  For i := 0 To lNewHeight do
  begin
    For j := 0 To lNewWidth do
    begin
      lSourceX := round((j + lMinX) * lCosine + (i + lMinY) * lSine);
      lSourceY := round((i + lMinY) * lCosine - (j + lMinX) * lSine);
      If (lSourceX >= 0) And (lSourceX <= lWidth) And (lSourceY >= 0) And
        (lSourceY <= lHeight) Then
        BitBlt(hNewBitmapDC, j, i, 1, 1, hBitmapDC, lSourceX, lSourceY,
          SRCCOPY);
    end;
  end;

  // reset the new bitmap width and height
  lWidth := lNewWidth;
  lHeight := lNewHeight;

  // return the DC to the new bitmap
  hBitmapDC := hNewBitmapDC;

  // destroy the bitmap created
  DeleteObject(hNewBitmap);
End;

initialization

// -----------------------------
// this is a brush used in fillrect of rotate
Brush := TBrush.create;
Brush.Style := bsSolid;
// Brush.Color := $FFFEFF;
// -----------------------------
TmpBrush := TBrush.create;
TmpPen := TPen.create;
TmpFont := TFont.create;

// these are tmp Brush and pen for Assign BMP
finalization

Brush.Free;
TmpBrush.Free;
TmpPen.Free;
TmpFont.Free;

end.
